home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / ENTRY.SWG / 0009_DATABOX.PAS.pas < prev    next >
Pascal/Delphi Source File  |  1994-02-03  |  16KB  |  441 lines
  1. unit databox;
  2.  
  3. { This is a unit to let you open data-entry boxes on the screen for quick 'n'
  4.   easy data entry.  It operates on variables of type "string", "integer",
  5.   "word", "byte", "longint" and "boolean".  There are two main routines to
  6.   call here:
  7.  
  8.     OpenBox(x, y, data, temp, type) -- to open a data entry box on the screen
  9.     ReadBoxes -- to read all data entry boxes
  10.  
  11.   The parameters for "OpenBox":
  12.     x, y -- the coordinates where the box should appear on the screen
  13.     data -- the variable you want to do data entry on
  14.     type -- an character indicating what type of variable you're working on.
  15.             Valid "types" are:
  16.  
  17.             'S' -- String            'I' -- Integer
  18.             'W' -- Word              'L' -- LongInt
  19.             'Y' -- Byte              'B' -- Boolean
  20.  
  21.     temp -- a string "template" indicating the size of the data entry
  22.             field and the data acceptable at each position.  The following
  23.             characters mean the following:
  24.  
  25.             'X' -- accept any character                 ( strings )
  26.             '!' -- accept any character, but capitalize ( strings )
  27.             '9' -- accept only digits and minus signs   ( numeric )
  28.             'T' -- accept only 'T' and 'F'              ( boolean )
  29.             'Y' -- accept only 'T', 'F', 'Y' and 'N'    ( boolean )
  30.  
  31.             All of these template characters are valid on strings.  For
  32.             numeric fields, the whole template gets converted to all 9's;
  33.             for boolean, the template will either be a single 'T' or 'Y'
  34.             (it defaults to 'T').
  35.  
  36.     Examples:
  37.  
  38.       OpenBox(12, 10, counter, '99999', 'I');
  39.  
  40.       -- is for an integer variable "counter".  It opens a data entry box at
  41.          position (12, 10), and is five characters across.
  42.  
  43.       OpenBox(1, 14, yes_or_no, 'Y', 'b')
  44.  
  45.       -- opens a data entry box for a boolean variable "yes_or_no", and will
  46.          accept only a "Y" or an "N" as input.
  47.  
  48.       OpenBox(1, 25, namestring, '!XXXXXXXXXXXXXXXX', 's')
  49.  
  50.       -- opens a data entry box for a string variable "namestring"; it will
  51.          automatically capitalize the first letter, and accept every other
  52.          character entered "as is".
  53.  
  54.     When you have opened all your data boxes, call "ReadBoxes" to allow
  55.     the user to actually input into the boxes.  Once you are done, the
  56.     boxes "close" so you can't do any more data entry on them.  There is
  57.     also a "ClearBoxes" procedure to manually "close" open boxes, and a
  58.     "Qwrite" procedure for doing direct video writes.
  59.  
  60.     Oh, I'm Lou Duchez, and if you could leave my name somewhere in the
  61.     code I'd appreciate it.  I'll never be rich off of public domain code
  62.     like this, so at least help me get famous ...
  63.   }
  64. {
  65. -------------------------------------------------------
  66. }
  67. interface
  68.  
  69. const boxforeground: byte = 1;
  70.       boxbackground: byte = 7;
  71.  
  72. procedure qwrite(x, y: byte; s: string; f, b: byte);
  73. procedure openbox(x, y: byte; var data; template: string; datatype: char);
  74. procedure clearboxes;
  75. procedure readboxes;
  76. {
  77. -------------------------------------------------------
  78. }
  79. implementation
  80. uses crt;       { for "checkbreak" and "readkey" functions }
  81.  
  82. const maxboxes = 255;     { open up to 255 data boxes simultaneously }
  83.  
  84. type boxrecord = record   { holds all the data we need }
  85.      x, y: byte;          { position to display on screen }
  86.      template: string;    { describes size and type of data field }
  87.      dataptr: pointer;    { points to data }
  88.      datatype: char;      { type of data we're pointing to }
  89.      end;
  90.  
  91. var boxes: array[1 .. maxboxes] of ^boxrecord;  { all the data boxes }
  92.     boxcount, thisbox, boxpos, boxlength: byte;
  93.     boxstring: string;
  94.     boxmodified: boolean;
  95. {
  96. -------------------------------------------------------
  97. }
  98. procedure qwrite(x, y: byte; s: string; f, b: byte);  { direct video writes }
  99.  
  100. { x, y: coordinates to display string at }
  101. { s: the string to display }
  102. { f, b: the foreground and background colors to display in }
  103.  
  104. type  videolocation = record           { video memory locations }
  105.         videodata: char;               { character displayed }
  106.         videoattribute: byte;          { attributes }
  107.         end;
  108.  
  109. var cnter: byte;
  110.     videosegment: word;
  111.     vidptr: ^videolocation;
  112.     videomode: byte absolute $0040:$0049;
  113.     scrncols: byte absolute $0040:$004a;
  114.     monosystem: boolean;
  115. begin
  116.  
  117. { Find the memory location where the string will be displayed at, according to
  118.   the monitor type and screen location.  Then associate the pointer VIDPTR with
  119.   that memory location: VIDPTR is a pointer to type VIDEOLOCATION.  Insert the
  120.   screen data and attribute; now go to the next character and video location. }
  121.  
  122.   monosystem := (videomode = 7);
  123.   if monosystem then videosegment := $b000 else videosegment := $b800;
  124.   vidptr := ptr(videosegment, 2*(scrncols*(y - 1) + (x - 1)));
  125.   for cnter := 1 to length(s) do begin
  126.     vidptr^.videoattribute := (b shl 4) + f;
  127.     vidptr^.videodata := s[cnter];
  128.     inc(vidptr);
  129.     end;
  130.   end;
  131. {
  132. -------------------------------------------------------
  133. }
  134. procedure movecursor(boxnum, position: byte);          { Positions cursor. }
  135. var tmpx, tmpy: byte;
  136. begin
  137.   tmpx := (boxes[boxnum]^.x - 1) + (position - 1);
  138.   tmpy := (boxes[boxnum]^.y - 1);
  139.   asm
  140.     mov ah, 02h           { Move cursor here.  I don't use GOTOXY because it }
  141.     mov bh, 00h           { is window-dependent. }
  142.     mov dh, tmpy
  143.     mov dl, tmpx
  144.     int 10h
  145.     end;
  146.   end;
  147. {
  148. -------------------------------------------------------
  149. }
  150. procedure openbox(x, y: byte; var data; template: string; datatype: char);
  151. var i: byte;
  152.     datastring, tempstring: ^string;
  153. begin
  154.   if boxcount < maxboxes then begin   { If we have room for another data }
  155.     inc(boxcount);                    { box, allocate memory for it from }
  156.     new(boxes[boxcount]);             { the heap and fill its fields. }
  157.     boxes[boxcount]^.x := x;
  158.     boxes[boxcount]^.y := y;
  159.     boxes[boxcount]^.dataptr := @data;
  160.     boxes[boxcount]^.template := template;
  161.     boxes[boxcount]^.datatype := upcase(datatype);
  162.     case upcase(datatype) of
  163.  
  164.     { "Fix" data entry template as needed.  Make sure the string data and
  165.       the template are of the same length.  Numeric templates should consist
  166.       of all 9's.  Boolean templates should be either 'Y' or 'T'. }
  167.  
  168.       'S': begin
  169.              datastring := boxes[boxcount]^.dataptr;
  170.              tempstring := addr(boxes[boxcount]^.template);
  171.              while length(datastring^) < length(tempstring^) do
  172.                    datastring^ := datastring^ + ' ';
  173.              while length(tempstring^) < length(datastring^) do
  174.                    tempstring^ := tempstring^ + ' ';
  175.              end;
  176.       'W', 'I', 'L', 'Y': for i := 1 to length(template) do
  177.                           boxes[boxcount]^.template[i] := '9';
  178.       'B': begin
  179.              boxes[boxcount]^.template[0] := #1;
  180.              if not (boxes[boxcount]^.template[1] in ['Y', 'T']) then
  181.                 boxes[boxcount]^.template := 'T';
  182.              end;
  183.       end;
  184.     end;
  185.   end;
  186. {
  187. -------------------------------------------------------
  188. }
  189. procedure clearboxes;           { Free up all memory for "box" data. }
  190. begin
  191.   while boxcount > 0 do begin
  192.     dispose(boxes[boxcount]);
  193.     dec(boxcount);
  194.     end;
  195.   end;
  196. {
  197. -------------------------------------------------------
  198. }
  199. procedure fixstring(boxnumber: byte);   { Adjusts string for displaying }
  200. var i: byte;                            { so that each character adheres to }
  201. begin                                   { the corresponding template char. }
  202.   for i := 1 to length(boxstring) do
  203.     case upcase(boxes[boxnumber]^.template[i]) of
  204.       'X': ;
  205.       '!': boxstring[i] := upcase(boxstring[i]);
  206.       '9': if not (boxstring[i] in ['-', '0' .. '9']) then boxstring[i] := ' ';
  207.       'T': case upcase(boxstring[i]) of
  208.            'Y', 'T': boxstring[i] := 'T';
  209.            'N', 'F': boxstring[i] := 'F';
  210.            else boxstring[i] := ' ';
  211.            end;
  212.       'Y': case upcase(boxstring[i]) of
  213.            'Y', 'T': boxstring[i] := 'Y';
  214.            'N', 'F': boxstring[i] := 'N';
  215.            else boxstring[i] := ' ';
  216.            end;
  217.       end;
  218.   qwrite(boxes[boxnumber]^.x, boxes[boxnumber]^.y, boxstring,
  219.          boxforeground, boxbackground);
  220.   end;
  221. {
  222. -------------------------------------------------------
  223. }
  224. procedure displaybox(boxnumber: byte); { Convert data to string and display. }
  225. var lentemplate: byte;
  226.     pntr: pointer;
  227. begin
  228.   pntr := boxes[boxnumber]^.dataptr;
  229.   lentemplate := length(boxes[boxnumber]^.template);
  230.   case boxes[boxnumber]^.datatype of
  231.     'S':  boxstring := string(pntr^);
  232.     'I':  str(integer(pntr^): lentemplate, boxstring);
  233.     'W':  str(word(pntr^):    lentemplate, boxstring);
  234.     'Y':  str(byte(pntr^):    lentemplate, boxstring);
  235.     'L':  str(longint(pntr^): lentemplate, boxstring);
  236.     'B':  if boolean(pntr^) then boxstring := 'T' else boxstring := 'F';
  237.     end;
  238.     fixstring(boxnumber);
  239.   end;
  240. {
  241. -------------------------------------------------------
  242. }
  243. procedure deletekey;    { delete: remove character at cursor and shift over }
  244. var i: byte;
  245. begin
  246.   boxmodified := true;
  247.   for i := boxpos to boxlength - 1 do  boxstring[i] := boxstring[i + 1];
  248.   boxstring[boxlength] := ' ';
  249.   end;
  250.  
  251. procedure backspace;        { backspace: back up one and delete if we're }
  252. begin                       { still in the same box }
  253.   boxpos := boxpos - 1;
  254.   if boxpos = 0 then begin
  255.     dec(thisbox);
  256.     boxpos := 255;
  257.     end
  258.    else deletekey;
  259.   end;
  260.  
  261. { Enter, Tab, and Shift-Tab move you to the beginning of prev/next box }
  262.  
  263. procedure enterkey;   begin inc(thisbox); boxpos := 1; end;
  264. procedure tab;        begin inc(thisbox); boxpos := 1; end;
  265. procedure reversetab; begin dec(thisbox); boxpos := 1; end;
  266.  
  267. { PgUp, PgDn, Esc take you out of editing; "Esc" indicates that the
  268.   "current" box should not be updated }
  269.  
  270. procedure pageup;     begin thisbox := 0; end;
  271. procedure pagedown;   begin thisbox := 0; end;
  272. procedure esckey;     begin thisbox := 0; boxmodified := false; end;
  273.  
  274. { Up / Down }
  275.  
  276. procedure moveup;     begin dec(thisbox); end;
  277. procedure movedown;   begin inc(thisbox); end;
  278.  
  279. procedure moveleft;   { Move left; if we go too far left, move up }
  280. begin
  281.   dec(boxpos);
  282.   if (boxpos = 0) then begin
  283.     boxpos := 255;
  284.     moveup;
  285.     end;
  286.   end;
  287.  
  288. procedure moveright;  { Move right; if we go too far right, move down }
  289. begin
  290.   inc(boxpos);
  291.   if (boxpos > boxlength) then begin
  292.     boxpos := 1;
  293.     movedown;
  294.     end;
  295.   end;
  296.  
  297. procedure literalkey(keyin: char);  { accept character into field }
  298. var i: byte;
  299.     goodkey, insmode: boolean;
  300.     keyboardstat: byte absolute $0040:$0017;
  301. begin
  302.   case upcase(boxes[thisbox]^.template[boxpos]) of   { does char match tmplt? }
  303.     '9': goodkey := (keyin in ['-', '0'..'9']);
  304.     'T': goodkey := (upcase(keyin) in ['T', 'F']);
  305.     'Y': goodkey := (upcase(keyin) in ['T', 'F', 'Y', 'N']);
  306.     else goodkey := true;
  307.     end;
  308.   if goodkey then begin             { character matches template -- use it }
  309.     boxmodified := true;
  310.     insmode := (keyboardstat and $80 = $80);
  311.     if insmode then begin
  312.       i := length(boxstring);       { "Insert" mode: make space for new char }
  313.       while i > boxpos do begin
  314.         boxstring[i] := boxstring[i - 1];
  315.         dec(i);
  316.         end;
  317.       end;
  318.     boxstring[boxpos] := keyin;     { enter character and move to the right }
  319.     moveright;
  320.     end;
  321.   end;
  322. {
  323. -------------------------------------------------------
  324. }
  325. procedure readbox;  { get data input on the box specified by THISBOX }
  326. var keyin: char;
  327.     startingbox, i: byte;
  328.     pntr: pointer;
  329.     dummyint: integer;
  330.     numstring: string;
  331. begin
  332.   boxmodified := false;             { "housekeeping" here }
  333.   startingbox := thisbox;
  334.   displaybox(thisbox);
  335.   boxlength := length(boxstring);
  336.   if boxpos > boxlength then boxpos := boxlength;   { cursor positioning }
  337.   if boxpos < 1 then boxpos := 1;
  338.   while (thisbox = startingbox) and
  339.         (boxpos >= 1) and (boxpos <= boxlength) do begin  { process field }
  340.     fixstring(startingbox);
  341.     movecursor(startingbox, boxpos);
  342.     keyin := readkey;                         { Interpret keystrokes here }
  343.     case keyin of
  344.        #0:  case readkey of
  345.               #15:  reversetab;
  346.               #72:  moveup;
  347.               #73:  pageup;
  348.               #75:  moveleft;
  349.               #77:  moveright;
  350.               #80:  movedown;
  351.               #81:  pagedown;
  352.               #83:  deletekey;
  353.               end;
  354.        #8:  backspace;
  355.        #9:  tab;
  356.       #13:  enterkey;
  357.       #27:  esckey;
  358.       else  literalkey(keyin);
  359.       end;
  360.     end;
  361.   if boxmodified then begin       { If data was changed, update variable }
  362.  
  363.     { This section handles numeric decoding.  Since "Val" gets real uppity
  364.       if there are spaces in the middle of your string, these couple loops
  365.       isolates the first section of the data entry string surrounded by
  366.       spaces.  Then "Val" processes that part. }
  367.  
  368.     i := 1;
  369.     while (i <= length(boxstring)) and (boxstring[i] = ' ') do inc(i);
  370.     numstring[0] := #0;
  371.     while (i <= length(boxstring)) and (boxstring[i] <> ' ') do begin
  372.       inc(numstring[0]);
  373.       numstring[length(numstring)] := boxstring[i];
  374.       inc(i);
  375.       end;
  376.     pntr := boxes[startingbox]^.dataptr;
  377.  
  378.     { Put the updated data back into its original variable. }
  379.  
  380.     case boxes[startingbox]^.datatype of
  381.       'S': string(pntr^) := boxstring;
  382.       'I': val(numstring, integer(pntr^), dummyint);
  383.       'W': val(numstring, word(pntr^),    dummyint);
  384.       'Y': val(numstring, byte(pntr^),    dummyint);
  385.       'L': val(numstring, longint(pntr^), dummyint);
  386.       'B': boolean(pntr^) := (upcase(boxstring[1]) = 'Y') or
  387.                              (upcase(boxstring[1]) = 'T');
  388.       end;
  389.     end;
  390.  
  391.   { Do a final data display. }
  392.  
  393.   displaybox(startingbox);
  394.   movecursor(startingbox, boxlength + 1);
  395.   end;
  396. {
  397. -------------------------------------------------------
  398. }
  399. procedure readboxes;          { gets data input on all boxes }
  400. var oldcheckbreak: boolean;
  401. begin
  402.   oldcheckbreak := checkbreak;
  403.   checkbreak := false;
  404.   for thisbox := 1 to boxcount do displaybox(thisbox);  { display data boxes }
  405.   thisbox := 1;
  406.   boxpos := 1;
  407.   while (thisbox >= 1) and (thisbox <= boxcount) do readbox;
  408.   clearboxes;
  409.   checkbreak := oldcheckbreak;
  410.   end;
  411. {
  412. -------------------------------------------------------
  413. }
  414. begin               { initialize to "no boxes" }
  415.   boxcount := 0;
  416.   end.
  417.  
  418. ==============================================================================
  419. TEST PROGRAM:
  420. ==============================================================================
  421. program datatest;
  422. uses databox, crt;
  423.  
  424. var i: integer;    s: string;     w: word;
  425.     b: boolean;    l: longint;    y: byte;
  426.  
  427. begin
  428.   clrscr;
  429.   i := 10;              openbox(1, 1, i, '999999', 'i');
  430.   w := 10;              openbox(1, 3, w, '999999', 'w');
  431.   s := 'SpamBurger';    openbox(1, 5, s, '!xxxxxxxxxxxxxxx', 's');
  432.   readboxes;
  433.   gotoxy(1, 18);  writeln(i);  writeln(w);  writeln(s);
  434.  
  435.   b := false;           openbox(1, 7, b, 'Y', 'b');
  436.   l := 10;              openbox(1, 9, l, '9999999999', 'l');
  437.   y := 20;              openbox(1,11, y, '9999999999', 'y');
  438.   readboxes;
  439.   gotoxy(1, 21);  writeln(b);  writeln(l);  writeln(y);
  440.   end.
  441.